Shareware Super Platinum 8

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / FIELDS.PRG < prev next >

Wrap

Text File | 1993-11-22 | 34.6 KB | 867 lines

*----------------------------------------------------------------------- *-- Program...: FIELDS.PRG *-- Programmer: Ken Mayer (CIS: 71333,1030) *-- Date......: 08/31/1993 *-- Notes.....: These field processing routines were deemed as not as *-- commonly used (at least in my own Applications), and *-- relegated to a library file. See: README.TXT about how *-- to use this library file. *----------------------------------------------------------------------- FUNCTION MemoPagr *----------------------------------------------------------------------- *-- Programmer..: Martin Leon (HMAN - ATBBS/Borland BBS) *-- Date........: 10/28/1991 *-- Notes.......: Used to display a memo on screen, allowing user to *-- scroll memo at will. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 10/28/1991 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ?MemoPagr(<cMemo>,<nUlrow>,<nUlcol>, ; *-- <nBrrow>,<nBrcol>) *-- Example.....: ?MemoPagr(MoreData,10,20,20,65) *-- Returns.....: .F. *-- Parameters..: cMemo = name of memo field *-- nUlrow = upper left row position *-- nUlcol = upper left column position *-- nBrrow = bottom right row position *-- nBrcol = bottom right column position *----------------------------------------------------------------------- parameters cMemo, nUlrow, nUlcol, nBrrow, nBrcol private cCursor, nEsc, nPgdn, nPgup, nUp, nDn, ; nNumlines, nLines, nKey, nAtline, nAtrow *-- set environment set memowidth to m->nBrcol - m->nUlcol - 1 m->cCursor = set( "CURSOR" ) set cursor off *-- define a few keys m->nEsc = 27 m->nPgdn = 3 m->nPgup = 18 m->nUp = 5 m->nDn = 24 *-- determine size of window m->nNumlines = memlines(&cMemo.) m->nLines = m->nBrrow - m->nUlrow - 1 *-- save the screen, so we can restore it save screen to sTmp @ m->nUlrow+1, m->nUlcol+1 clear to m->nBrrow+1, m->nBrcol+1 @ m->nUlrow+1, m->nUlcol+1 fill to m->nBrrow+1, m->nBrcol+1 color B/N @ m->nUlrow+1, m->nUlcol+1 fill to m->nBrrow-1, m->nBrcol-1 ; color RG+/B @ m->nUlrow, m->nUlcol to m->nBrrow, m->nBrcol double color RG+/B *-- deal with a blank memo ... if m->nNumlines = 0 @ m->nUlrow + 1, m->nUlcol + 1 SAY ; "Blank Memo. Press any key to continue..." color RG+/B m->nKey = inkey(0) *-- reset the whole thing restore screen from sTmp release screen sTmp set cursor &cCursor. RETURN .F. endif m->nAtline = 1 m->nAtrow = 1 do while m->nAtline <= m->nNumlines *-- Show one window full do while m->nAtrow <= m->nLines .and. m->nAtline <= m->nNumlines @ m->nUlrow+m->nAtrow, m->nUlcol + 1 SAY ; mline( &cMemo., m->nAtline ) color RG+/B m->nAtline = m->nAtline + 1 m->nAtrow = m->nAtrow + 1 enddo *-- If at last line of memo... if m->nAtline > m->nNumlines *-- If memo is shorter than one page, put box character in *-- bottom left corner of box, otherwise, put an up arrow *-- symbol there. @ m->nBrrow - 1, m->nBrcol SAY ; iif(m->nNumlines <= m->nLines, chr(186), chr(24)) color W+/B do while .T. m->nKey = inkey(0) *-- If memo is shorter than one page, only allow *-- ESC key if m->nNumlines <= m->nLines if m->nKey = m->nEsc exit endif *-- Otherwise, allow Esc or PgUp keys else if m->nKey = m->nEsc ; .or. m->nKey = m->nPgup ; .or. m->nKey = m->nUp exit endif endif ?? chr(7) enddo if m->nKey = m->nEsc restore screen from sTmp release screen sTmp set cursor &cCursor. RETURN .F. endif @ m->nUlrow+1, m->nUlcol+1 clear to m->nBrrow-1, m->nBrcol-1 @ m->nUlrow+1, m->nUlcol+1 fill to m->nBrrow-1, m->nBrcol-1 ; color RG+/B m->nAtline = m->nAtline - m->nAtrow - m->nLines + 1 m->nAtline = iif( m->nAtline < 1, 1, m->nAtline ) m->nAtrow = 1 loop endif *-- Not at end of memo yet... *-- If on first page, show down arrow only, otherwise show *-- up/down arrow on border of box. @ m->nBrrow - 1, m->nBrcol say ; iif(m->nAtline-m->nLines = 1, chr(25), chr(18)) color W+/B do while .T. m->nKey = inkey(0) *-- If this is the first page of the memo on screen... if m->nAtline - m->nLines = 1 *-- Only honor PgDn, up cursor, and Esc keys if m->nKey = m->nPgdn .or. m->nKey = m->nDn ; .or. m->nKey = m->nEsc exit endif *-- otherwise honor PgUp and up cursor as well key as well else if m->nKey = m->nPgup .or. m->nKey = m->nUp ; .or. m->nKey = m->nPgdn ; .or. m->nKey = m->nDn ; .or. m->nKey = m->nEsc exit endif endif ?? chr(7) enddo do case case m->nKey = m->nEsc restore screen from sTmp release screen sTmp set cursor &cCursor. RETURN .F. case m->nKey = m->nPgup .or. m->nKey = m->nUp @ m->nUlrow+1, m->nUlcol+1 clear to m->nBrrow-1, m->nBrcol-1 @ m->nUlrow+1, m->nUlcol+1 fill to m->nBrrow-1, m->nBrcol-1; color RG+/B m->nAtline = (m->nAtline - (2 * m->nLines)) m->nAtline = iif( m->nAtline < 1, 1, m->nAtline ) m->nAtrow = 1 loop case m->nKey = m->nPgdn .or. m->nKey = m->nDn @ m->nUlrow+1, m->nUlcol+1 clear to m->nBrrow-1, m->nBrcol-1 @ m->nUlrow+1, m->nUlcol+1 fill to m->nBrrow-1, m->nBrcol-1; color RG+/B m->nAtrow = 1 loop endcase enddo RETURN .F. *-- EoF: MemoPagr() PROCEDURE ScanMemo *----------------------------------------------------------------------- *-- Programmer..: Martin Leon (HMAN) *-- Date........: 02/27/1992 *-- Notes.......: This simple procedure is used to strip hard carriage *-- returns out of all Memos in a database. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 04/15/1991 - original procedure. *-- 02/07/1992 -- Douglas P. Saine (XRED) modified to *-- handle passing of database name as a parameter *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Do ScanMemo with "<cDbf>" *-- Example.....: Do ScanMemo with "TEST" *-- Returns.....: None. *-- Parameters..: cDbf = Name of the database to scan memos ... *----------------------------------------------------------------------- parameters cDbf private nFields, cFieldname, nLines, nLinenum use (m->cDbf) scan && search database 1 record at a time ... m->nFields = 1 *-- This loop goes through all fields in the database do while asc(field(m->nFields)) # 0 m->cFieldname = field(m->nFields) && save current field name if type(m->cFieldname) = "M" && check to see if it's a memo m->nLines = memlines(&cFieldname.) && # of lines in memo if m->nLines > 1 && if there's something there delete file temp.txt && kill old file if it exists set printer to file temp.txt && copy memo a line at a time m->nLinenum = 1 && to temp file, using ??? do while m->nLinenum <= m->nLines && command. ??? mline(&cFieldname.,m->nLinenum) ??? " " m->nLinenum = m->nLinenum + 1 enddo close printer set printer to append memo &cFieldname. from temp.txt overwrite endif && m->nLines > 1 endif && type(m->cFieldname) = "M" m->nFields = m->nFields + 1 && go to next field ... enddo && asc(field.... endscan && scan of database record by record ... use && close database RETURN *-- EoP: ScanMemo PROCEDURE Cut *----------------------------------------------------------------------- *-- Programmer..: Michael B. Carlisle (Borland) *-- Date........: 01/01/1992 *-- Notes.......: This retrieves information from the field the user *-- has currently selected and stores the information *-- into a memory variable titled CLIPBOARD. The field *-- itself is then cleared. CLIPBOARD should be declared *-- public. *-- This routine is taken from TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 01/01/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do CUT with "<cFld>","<cScrtype>" *-- Example.....: on key label F6 do CUT with varread(),"READ" *-- Returns.....: None *-- Parameters..: cFld = Field to 'CUT' the data from. *-- cScrtype = What screen type? Valid options are *-- BROWSE, EDIT and READ. *----------------------------------------------------------------------- parameters cFld,cScrtype *-- test field type, ignore if field is memo clipboard = iif(type(m->cFld) = "D",; right(dtos(&cFld.),4)+substr(dtos(&cFld.),3,2),; iif(type(m->cFld) = "L",iif(&cFld.,"T","F"),; iif(type(m->cFld)="M","",&cFld.))) *-- if field type is Numeric or Float, convert to string. if type(m->cFld) $ "NF" clipboard = ltrim(str(int(fixed(&cFld.)),20)+; right(str(fixed(&cFld.) - int(fixed(&cFld.)),20,18,19)) do while val(right(clipboard,1)) = 0 ; .and. .not. right(clipboard,1) = "." clipboard = LEFT(clipboard,LEN(clipboard)-1) enddo endif *-- Ring bell if field is MEMO, otherwise, clear the field if type(m->cFld) = "M" ?? chr(7) else *-- do to difference in function of the HOME keys in BROWSE mode, *-- Ctrl-Home has to be used in BROWSE if upper(m->cScrtype) = "BROWS" keyboard chr(29)+chr(25) && go to beginning of field and clear else keyboard chr(26)+chr(25) && ditto endif endif RETURN *-- EoP: Cut PROCEDURE COPY *----------------------------------------------------------------------- *-- Programmer..: Michael B. Carlisle (Borland) *-- Date........: 01/01/1992 *-- Notes.......: This retrieves information from the field the user *-- has currently selected and stores the information *-- into a memory variable titled CLIPBOARD. The field *-- itself is left 'as is' (unlike CUT). CLIPBOARD *-- should be declared public. This routine is taken *-- from TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 01/01/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do COPY with "<cFld>" *-- Example.....: on key label F8 do COPY with varread() *-- Returns.....: None *-- Parameters..: cFld = Field to 'COPY' the data from. *----------------------------------------------------------------------- parameters cFld *-- test field type, ignore if field is memo clipboard = iif(type(m->cFld) = "D",; right(dtos(&cFld.),4)+substr(dtos(&cFld.),3,2),; iif(type(m->cFld.) = "L",iif(&cFld.,"T","F"),; iif(type(m->cFld.)="M","",&cFld.)) *-- if field type is Numeric or Float, convert to string. if type(m->cFld) $ "NF" clipboard = ltrim(str(int(fixed(&cFld.),20) + ; right(str(fixed(&cFld. - int(fixed(&cFld.),20,18,19)) do while val(right(clipboard,1)) = 0 ; .and. .not. right(clipboard,1)="." clipboard = left(clipboard,len(clipboard)-1) enddo endif *-- Ring bell if field is MEMO, otherwise, clear the field if type(m->cFld) = "M" ?? chr(7) endif RETURN *-- EoP: Copy PROCEDURE Paste *----------------------------------------------------------------------- *-- Programmer..: Michael B. Carlisle (Borland) *-- Date........: 01/01/1992 *-- Notes.......: Paste writes out the contents of the CLIPBOARD *-- (public) memvar to the currently selected field. *-- Because all values are converted to strings when *-- stored into the CLIPBOARD, Paste is able to write *-- values from one field type to another (such as *-- numeric to character, date to numeric, etc.). This *-- routine is taken from TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 01/01/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do PASTE with "<cFld>","<cScrtype>" *-- Example.....: on key label F7 do PASTE with varread(), "READ" *-- Returns.....: None *-- Parameters..: cFld = Field to 'PASTE' data in CLIPBOARD to. *-- cScrtype = What screen type? Valid options are *-- BROWSE, EDIT and READ. *----------------------------------------------------------------------- parameters cFld, cScrtype *-- ring bell if field is MEMO, otherwise, fill the field. if type(m->cFld) = "M" ?? chr(7) else *-- due to difference in function of HOME in the BROWSE mode, *-- Ctrl-Home has to be used in BROWSE. if upper(m->cScrtype) = "BROWSE" keyboard chr(29)+chr(25)+ClipBoard && go to beginning of field, && and clear, putting cont- && tents of clipboard in. else keyboard chr(26)+chr(25)+ClipBoard endif endif && type ... RETURN *-- EoP: Paste FUNCTION Blanker *----------------------------------------------------------------------- *-- Programmer..: Curt Schroeders (Borland Tech Support) *-- Date........: 07/01/1992 *-- Notes.......: used to BLANK a numeric field once the user presses *-- a key that may be used IN a numeric field. SIDE *-- EFFECT -- if you use this function, the original *-- value in the field will be erased ... this does not *-- allow editing of the numeric field. *-- Written for.: dBASE IV, 1.5 (should work in 1.1) *-- Rev. History: 07/01/1992 -- Original *-- 07/13/1992 -- Ken Mayer - added '-' and '.' as valid *-- characters in list ... *-- Usage.......: Blanker() *-- Example.....: @5,10 get Salary when blanker() *-- Returns.....: Logical *-- Parameters..: None *----------------------------------------------------------------------- private nX *-- get keystroke from user m->nX = inkey(0) *-- if nX is in list if chr(m->nX) $ "0123456789-." keyboard "{CTRL-Y}" && blank out field endif keyboard chr(m->nX) && return this character ... RETURN .T. *-- EoF: Blanker() FUNCTION GetRange *----------------------------------------------------------------------- *-- Programmer..: Joey D. Carroll (JOEY) *-- Date........: 10/12/1992 *-- Notes.......: A function to get a range for use with 'set key to *-- range x,y' or 'set filter to'. Works with character, *-- numeric, float, and date types. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 11/08/1992 Changed to protect active windows. *-- Added SHADOW (JOEY) *-- 11/09/1992 Added (optional) cStyle parameter (JOEY) *-- Calls.......: CENTER Procedure in PROC.PRG *-- SHADOW Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: ?? GetRange(<cText>,<xPara1>,<xPara2>,<cPicture>, ; *-- <nStartrow>,<cColor>[,cStyle]) *-- Example.....: * get a range for a date, dbf in use is ordered by *-- TRANDATE *-- dDate1={} *-- dDate2={} *-- ?? GetRange("Enter date range for your report", ; *-- dDate1,dDate2,"",10,"w+/r,n/w,w+/gb") *-- * now use values determined by getrange() *-- set key to range dDate1,dDate2 *-- go top *-- * if the dbf is not indexed on a date or if you *-- * just =have= to use a filter e.g.-- *-- * set filter to Transdate >= dDate1 .and. ; *-- Transdate <= dDate2 *-- report form <yourreport> to print *-- Returns.....: .t. if correct type parameters, otherwise .f. *-- Parameters..: cText = Message to center in window. May be nul "". *-- xPara1 = First elemement of the 'key'. *-- The 'width' of the character 'get' is *-- determined by len(xPara1). *-- The 'width' of the date 'get' is *-- determined by set("century"). *-- xPara2 = Second element of the 'key'. *-- cPicture = used to determine 'width' and format of *-- numeric or float 'get', and the format *-- of the character 'get'. May be nul "". *-- Ignored if xPara1 is date type. *-- nStartrow = Row to place top of window. *-- Message row (24) is protected. *-- cColor = Colors to be used ("Normal/HiLite/Box") *-- (may be nul "", in order to use the *-- default colors of window/screen) *-- cStyle = "H" = horizontal "V" = verticle (may be *-- omitted or ""/nul to default to "H" -- *-- =Very= long parameters default to "V") *----------------------------------------------------------------------- parameters cText,xPara1,xPara2,cPicture,nStartrow,cColor,cStyle private cTalk,cColor2,nSaylen,nPictlen,wPrevwind,nEndrow *-- is a window active wPrevwind = window() activate screen *-- in case no color is passed, this will prevent bomb m->cColor2 = iif(isblank(m->cColor),"","color &cColor.") *-- calculate window size based on parameters do case case type("m->xPara1") = "C" *-- xPara1,xPara2 should initialized with *-- space(len(alias->fieldname)) *-- or space(len(var)) m->nPictlen = 2 * len(m->xPara1) case type("m->xPara1") = "N" .or. type("m->xPara1") = "F" *-- gotta have a picture to define window width m->cPicture = iif(isblank(m->cPicture),"9999999999",; m->cPicture) m->nPictlen = 2 * len(m->cPicture) case type("m->xPara1")="D" m->nPictlen = 2 * (iif(set("CENTURY")="OFF",8,10)) otherwise if .not. isblank(wPrevwind) activate window &wPrevwind. endif ?? chr(7) RETURN .F. && stupid! endcase m->cText = " "+m->cText && don't jamb against box edge *-- is the window width going to be wider than 75 cols, OR was "V" *-- passed in the cStyle param? If so, use verticle style m->nSaylen = len("From: ") + len("To: ") m->nWindwidth = m->nSaylen + m->nPictlen + 7 *-- if len(cText) > nWindwidth, fix it m->nWindwidth = MAX(m->nWindwidth,len(m->cText) + 3) if m->nWindwidth <= 76 ; .and. (pcount() < 7 .or. upper(m->cStyle) = "H") m->cStyle = "H" && make it so m->nStartrow = MIN(m->nStartrow,16) && protect row 24 even from m->nStartcol = (80-m->nWindwidth) / 2 && shadow center the window m->nEndrow = m->nStartrow + 6 define window wGetrange from m->nStartrow,m->nStartcol to ; m->nEndrow, m->nStartcol+m->nWindwidth ; &cColor2. double else *-- wants verticle style or params are too wide for horizontal *-- so do some re-figgering m->cStyle = "V" && make it so m->nStartrow = MIN(m->nStartrow,14) && protect row 24 even from m->nEndrow = m->nStartrow + 8 && shadow *-- recalc window width for this style m->nSaylen = len("From: ") m->nPictlen = m->nPictlen / 2 && doubled for horz., so cut m->nWindwidth = m->nSaylen + m->nPictlen + 7 && by 1/2 *-- if len(cText) > nWindwidth, fix it m->nWindwidth = MAX(m->nWindwidth,len(m->cText) + 3) m->nStartcol = (80-m->nWindwidth) / 2 && center the window define window wGetrange from m->nStartrow,m->nStartcol to ; m->nEndrow, m->nStartcol+m->nWindwidth &cColor2. double endif save screen to sGetrange *-- now use what you've done so far do shadow with m->nStartrow,m->nStartcol,m->nEndrow,; m->nStartcol+m->nWindwidth activate window wGetrange do center with 1,m->nWindwidth - 2,"",m->cText @ 2,0 to 2,m->nWindwidth - 2 @ 3,2 say 'From:' GET m->xPara1 picture m->cpicture if m->cStyle = "H" @ 3,(m->nWindwidth- 2 ) - (len("To: ")) - (m->nPictlen/2) - 1 ; say 'to:' GET m->xPara2 picture m->cpicture else @ 5,4 say 'To:' GET m->xPara2 picture m->cpicture endif read *-- clean up your doin's deactivate window wGetrange restore screen from sGetrange release screen sGetrange release window wGetrange if .not. isblank(wPrevwind) activate window &wPrevwind. endif RETURN .T. *-- EoF: GetRange() FUNCTION FldWidth *----------------------------------------------------------------------- *-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 72662,1305) *-- Date........: 03/24/1993 *-- Notes.......: Returns the width of a field, without having to read *-- the .DBF structure into a file and use low-level *-- functions ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/28/1993 -- Original *-- 03/24/1993 -- Lee Hite -- Enhanced to accept a field *-- name as well as a field number, also added optional *-- <cAlias> to allow checking a file that is not *-- currently selected. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: FldWidth(<nField>[,<cAlias>]) *-- Example.....: ?FldWidth(3) or *-- ?FldWidth("MyField") or *-- ?FldWidth("MyField","MyFile") *-- Returns.....: Numeric value *-- Parameters..: nField = field number (or name) in file structure *-- cAlias = Optional file alias (defaults to current) *----------------------------------------------------------------------- parameters nField, cAlias private nReturn, cFldtype, cFldname, cDbf *-- Deal with alias passed as a parameter m->cDbf = iif(type("M->CALIAS") = "L",ALIAS(),m->cAlias) *-- deal with field parameter being numeric or character m->cFldname = iif(type("m->nField") = "N", ; field(m->nField,m->cDbf),m->nField) *-- ready to go ... m->cFldtype = type("&cDbf.->&cFldname.") && get the type ... do case case m->cFldtype = "L" m->nReturn = 1 case m->cFldtype = "D" m->nReturn = 8 case m->cFldtype = "C" m->nReturn = len(&cDbf.->&cFldname.) case m->cFldtype $ "NF" m->nReturn = len(transform(&cDbf.->&cFldname., "@L")) otherwise m->nReturn = 0 endcase RETURN m->nReturn *-- EoF: FldWidth() FUNCTION FldDec *----------------------------------------------------------------------- *-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 72662,1305) *-- Date........: 01/28/1993 *-- Notes.......: Returns the number of decimal places of a numeric *-- field. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/28/1993 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: FldDec(<nField>) *-- Example.....: ?FldDec(3) *-- Returns.....: Numeric value, 0 if non-numeric field type *-- Parameters..: nField = field number in file structure *----------------------------------------------------------------------- parameters nField private nReturn, cTemplate, cFldname m->cFldname = field(m->nField) if type(m->cFldname) $ "NF" && if it's numeric/float type m->cTemplate = transform(&cFldname.,"@L") m->nReturn = at(".",m->cTemplate) if m->nReturn > 0 m->nReturn = len(m->cTemplate) - m->nReturn endif else m->nReturn = 0 endif RETURN m->nReturn *-- EoF: FldDec() PROCEDURE PopMemo *----------------------------------------------------------------------- *-- Programmer..: Charles Miedzinski (CIS: 76711,671) Borland *-- Date........: 06/03/1993 *-- Notes.......: Charles posted this on CIS in the dBASE Forum, and I *-- cleaned it up a bit. It will bring up a popup with *-- the contents of a memo in it (which can then be *-- scanned in a read-only mode). *-- Written for.: dBASE IV, 1.5+ *-- Rev. History: 05/28/1993 -- Original posting on CIS *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do PopMemo with <nTop>,<nLeft>,<nBottom>,<nRight>, ; *-- <cMemoname> *-- Example.....: on key label F3 do PopMemo with 5,10,20,60, ; *-- "EmpRecord" *-- Returns.....: none *-- Parameters..: nTop = Top row of popup *-- nLeft = Left column of popup *-- nBottom = Bottom row of popup *-- nRight = Right column *-- cMemoname = Name of memofield *----------------------------------------------------------------------- parameters m->nTop, m->nLeft, m->nBottom, m->nRight, m->cMemoname *-- NOTE: if you assign this to a function key, comment out this *-- trap, and others noted in the routine, and change the function *-- key to the appropriate one: * on key label f3 ?? chr(7) *-- if empty memo if memlines(&cMemoname.) = 0 *-- NOTE: if assigned to a function key, uncomment these lines *-- and change function key to appropriate one * on key label f3 do popmemo with &nTop.,&nLeft., ; &nBottom., &nRight.,"&cMemoname." RETURN endif *-- define the popup define popup pMemo from m->nTop,m->nLeft to m->nBottom,m->nRight; message "Press <Esc> to RETURN to main screen" *-- determine width of memo lines based on coordinates of popup m->nMwidth = set("MEMOWIDTH") && save current, so we can restore it set memowidth to (m->nRight - m->nLeft - 2) && reserve room for border m->nCount = 1 m->nmemlines = memlines(&cMemoname.) do while m->nCount < m->nMemlines + 1 define bar m->nCount OF pMemo ; prompt mline(&cMemoname.,m->nCount) m->nCount = m->nCount + 1 enddo *-- what do we do when user selects a bar? (<Enter>) on selection popup pMemo deactivate popup activate popup pMemo *-- once done, let's clean up set memowidth to m->nMwidth release popup pMemo *-- NOTE: if you assigned this to a function key, uncomment the *-- following, and change key name. * on key label f3 do popmemo with &nTop.,&nLeft.,&nBottom.,; * &nRight., "&cMemoname." RETURN *-- EoP: PopMemo FUNCTION FldName *----------------------------------------------------------------------- *-- Programmer..: Bowen Moursund (CIS: 72662,436) *-- Date........: 07/12/1993 *-- Notes.......: FldName() uses low level file functions to write *-- directly to a DBF header, changing the name of a *-- specified field. *-- Written for.: dBASE IV, version 1.5, 2.0 *-- Rev. History: 07/12/1993 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: fldname( <cDbf>, <nField>, <cNewname> ) *-- Example.....: cName = fldname( "MYDBF.DBF", 5, "ADDRESS" ) *-- Returns.....: The new field name or a null string ("") on failure. *-- Parameters..: cDbf = The DBF name. Drive and path specs are OK. *-- The extension is required. *-- nField = The field number. *-- cNewname= The new field name. Leading and trailing *-- spaces will be trimmed, the name truncated *-- to 10 characters and converted to upper *-- case. *-- WARNINGS....: NO checking for illegal characters in the new field *-- name is made, so don't use any <g>. Since the DBF *-- header is directly altered, a backup might be *-- desirable in the event of failure. If a field used *-- in an index expression is changed, the index file *-- should be rebuilt. *----------------------------------------------------------------------- parameters m->cDbf, m->nField, m->cNewname private m->cDbf, m->nField, m->cNewname, m->nDbf, m->nNewloc, N, ; m->lSuccess,m->cRetstr m->lSuccess = .T. m->cNewname = upper( left( ltrim( rtrim( m->cNewname ) ), 10 ) ) use ( m->cDbf ) m->nFields = fldcount() use m->lSuccess = ( m->nField <= m->nFields .and. m->nField > 0) if m->lSuccess m->nOffset = ( 32 * m->nField ) m->nDbf = fopen( m->cDbf, "rw" ) m->lSuccess = ( m->nDbf > 0 ) if m->lSuccess m->nNewloc = fseek( m->nDbf, m->nOffset ) m->lSuccess = ( m->nNewloc = m->nOffset ) if m->lSuccess N = 1 do while N <= 11 m->nBytes = fwrite( m->nDbf, chr(0), 1 ) N = N + 1 enddo m->nNewloc = fseek( m->nDbf, m->nOffset ) m->lSuccess = ( m->nNewloc = m->nOffset ) if m->lSuccess m->nBytes = fwrite( m->nDbf, m->cNewname ) endif endif endif m->lSuccess = fclose( m->nDbf ) endif m->cRetstr = iif( m->lSuccess, m->cNewname, "" ) RETURN m->cRetstr *-- EoF: FldName() FUNCTION IsMatch *---------------------------------------------------------------------- *-- Programmers.: Bowen Moursund (CIS: 72662,436) and *-- Angus Scott-Fleming (CIS: 75500,3223) *-- Date........: 10/10/1993 *-- Notes.......: Checks for an index key match in the named DBF or *-- alias. Similar to version 2.0 KEYMATCH(), except that *-- a match of the current record is ignored. The UDF may *-- be used in 1 of 2 modes. If the optional parameter *-- cOrder is passed to the UDF, then a copy of the named *-- DBF will be opened in an unused work area, and the *-- check for a key match made on that copy. Do not use *-- this mode within a dBASE BEGIN/END TRANSACTION, as the *-- closing of the copy produces an error. If cOrder is *-- NOT passed to the UDF, it's required that you USE the *-- DBF twice, once for data entry and once for testing. *-- The second USE should include the keywords AGAIN *-- NOUPDATE: *-- use THEDBF order (cOrder) in select() alias XXX *-- use THEDBF order (cOrder) in select() alias YYY ; *-- again noupdate *-- WARNING: if you use BEGIN/END TRANSACTION, you must open *-- the testing database before using this function. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: IsMatch(<cAlias>,<xValue>[,<nRecNo>]) OR *-- : IsMatch(<cDBF>,<xValue>,<nRecNo>,<cOrder>) *-- Examples....: use THEDBF *-- use THEDBF order ID in select() alias DUPECHEK ; *-- again noupdate *-- @5,5 say "ID: " get ID picture "9999"; *-- valid requ .not.IsMatch("DUPECHEK", ID, recno()) ; *-- message "Enter ID" ; *-- error chr(7)+"ID must be unique!" *-- *-- use THEDBF *-- @5,5 say "ID: " get ID picture "9999" ; *-- valid requ .not. IsMatch(dbf(), ID, recno(), "ID") *-- *-- * editing a record with memvars *-- use THEDBF *-- use THEDBF order ID in select() alias DUPECHEK ; *-- again noupdate *-- @5,5 say "ID: " get m->cID picture "9999" ; *-- valid required .not. IsMatch("THEDBF", m->cID, 69) *-- Returns.....: .T./.F. *-- Parameters..: REQUIRED *-- cDbOrAlias = Name or alias of DBF to check for match *-- xValue = Value (non-memo type) to check for match *-- OPTIONAL *-- nRecNo = The current record number. Omit or set *-- to 0 if appending new records. *-- cOrder = Optional parameter. Production MDX Tag *-- used to order the DBF if it's not already *-- opened. Must allow SEEK on field being *-- checked. *----------------------------------------------------------------------- parameters cDbOrAlias, xValue, nRecNo, cOrder private nPcount, lRetVal nPcount = pcount() do case case m->nPcount = 2 && DBF is already open and ordered; adding lRetVal = seek(m->xValue,m->cDbOrAlias) case m->nPcount = 3 && if DBF is already open and ordered lRetVal = seek(m->xValue,m->cDbOrAlias) .and. ; (recno(m->cDbOrAlias) <> m->nRecno) case m->nPcount = 4 && need to open the DUPECHEK DBF private nNewArea nNewArea = select() use (m->cDbOrAlias) order tag cOrder) again in m->nNewArea ; noupdate alias DUPECHEK lRetVal = seek(m->xValue,"DUPECHEK") .and. ; (recno("DUPECHEK") <> m->nRecno) use in m->nNewArea endcase RETURN m->lRetVal *-- EoF: IsMatch() *----------------------------------------------------------------------- *-- EoP: FIELDS.PRG *-----------------------------------------------------------------------